Program SIMPLEX (INPUT,OUTPUT);
{$U+}
Var
   Bi , Ci , Cj , DeltaJ , Theta , Z , Zj : Array [1..20] of Real ;
   Basis : Array [1..20] of Integer ;
   Coef : Array [1..20 , 1..20] of Real ;
   I , J , Enter , Leave , Variable , Constraint : Integer ;
   Colcoef , Sum , Minimum , Pivot : Real ;
   Positive , Unbound : Boolean ;
{________________________________________________________________________}

Procedure GetZcoef ;  (* Accepts the coefficients in Z *)
begin
   Clrscr ;
   WRITELN (OUTPUT, '--------------');
   WRITELN (OUTPUT, 'SIMPLEX METHOD');
   WRITELN (OUTPUT, ' --------------',' ':80 );
   WRITE ( OUTPUT , 'Enter the number of variables involved ( Including ');
   WRITE ( OUTPUT , 'Regular , Slack , Surplus &  Artificial ) -> ');
   READLN ( INPUT , Variable ) ;
   WRITELN ( OUTPUT ) ;
   WRITE ( OUTPUT , 'Enter the coefficients corresponding to the ');
   WRITELN ( OUTPUT , 'following variables',' ':80 ) ;
   WRITELN (OUTPUT,'        For artificial variables enter ` M '' as 32767',' ':80);
   For I := 1 to Variable do
   begin
      WRITE ( OUTPUT , 'X' , I ,' -> ' );
      READLN ( INPUT , Z [I] ) ;
   end ;
   WRITELN ( OUTPUT ,' ':80, '                             Coefficients accepted !' );
   Delay ( 1500 );
   Clrscr ;
end ;
{________________________________________________________________________}

Procedure Concoef ;  (* Accept the coefficient matrix *)
begin
   Clrscr ;
   WRITELN (OUTPUT) ;
   WRITELN (OUTPUT) ;
   WRITE ( OUTPUT , 'Enter the total number of constraints -> ' ) ;
   READLN ( INPUT , Constraint ) ;
   For I := 1 to Constraint do
   begin
      Clrscr ;
      WRITELN ( OUTPUT , 'Constraint : ', I ) ;
      WRITELN ( OUTPUT , '--------------') ;
      WRITE ( OUTPUT , 'Enter the coefficients corresponding to the ');
      WRITELN ( OUTPUT , 'following variables',' ':80 ) ;
      For J := 1 to Variable do
      begin
         WRITE ( OUTPUT , 'X' , J ,' -> ' );
         READLN ( INPUT , Coef [I,J] ) ;
      end ;
      WRITELN (OUTPUT);
      WRITE ( OUTPUT , 'Enter the corresponding " b " value -> ' );
      READLN ( INPUT , Bi [I] ) ;
   end ;
   Delay ( 1000 ) ;
   Clrscr ;
end ;
{________________________________________________________________________}

Procedure Fillbas ;
Var
  Dummy : Integer ;
begin
   J := 0 ;
   For I := ( Variable - Constraint + 1 ) to Variable do
   begin
      J := J + 1 ;
      Basis [J] := I ;
   end;
end;
{________________________________________________________________________}

Procedure FillCi ;
begin
   For I := 1 to Constraint do
      Ci [I] := Z [Basis[I]] ;
end;
{________________________________________________________________________}

Procedure FillCj ;
begin
   For I := 1 to Variable do
      Cj [I] := Z [I] ;
end;
{________________________________________________________________________}

Procedure CalcZj ;
begin
   For I := 1 to Variable do
   begin
      Zj [I] := 0 ;
      For J := 1 to Constraint do
         Zj [I] := Zj [I] + ( Ci [J] * Coef [J,I] ) ;
   end;
end;
{________________________________________________________________________}

Procedure CalDelj ;
begin
   For I := 1 to Variable do
   begin
      Deltaj [I] := Zj [I] - Cj [I] ;
   end;
end;
{________________________________________________________________________}

Procedure PosDelj ;
begin
   Enter := 1 ;
   Minimum := Deltaj [1] ;
   For I := 2 to Variable do
   begin
      If ( Minimum  > deltaj [i] ) then
      begin
         Minimum := Deltaj [I] ;
         Enter := I ;
      end ;
   end;
   If ( Minimum < 0 ) then Positive := False
   else
       Positive := True ;
end;
{________________________________________________________________________}

Procedure Caltheta ;
begin
   For I := 1 to Constraint do
      If ( Coef [I,Enter] > 0 ) then
         Theta [I] := Bi [I] / Coef [I,Enter]
      else
         Theta [I] := 32767 ;
end;
{________________________________________________________________________}

Procedure Getleave ;
begin
   Minimum := Theta [1] ;
   Leave := 1;
   For I := 2 to Constraint do
      If ( Theta [I] < Minimum ) then
      begin
         Minimum := Theta [I] ;
         Leave := I ;
      end;
      If ( Minimum = 32767 ) then
         Unbound := True ;
end;
{________________________________________________________________________}

Procedure Modibas ;
begin
   Basis [Leave] := Enter ;
end;
{________________________________________________________________________}

Procedure Nupivrow ;
begin
   Pivot := Coef [Leave,Enter] ;
   For I := 1 to Variable do
      Coef [Leave,I] := Coef [Leave,I] / Pivot ;
   Bi [Leave] :=  Bi [Leave] / Pivot ;
end;
{________________________________________________________________________}

Procedure Newrow ;
begin
   For I := 1 to Constraint do
   begin
      If ( I <> Leave ) then
      begin
         Colcoef := Coef [I,Enter] ;
         For J := 1 to Variable do
            Coef [I,J] := Coef [I,J] - Colcoef *  Coef [Leave,J] ;
         Bi [I] := Bi [I] - Colcoef *  Bi [Leave] ;
      end;
   end;
end;
{________________________________________________________________________}

Procedure FinalZ ;
begin
   Sum := 0 ;
   for I:= 1 to Variable do
      Sum := Sum + ( Z [Basis [I]] * Bi [I] ) ;
   gotoXY ( 24 , 12 );
   WRITELN ( OUTPUT,'Optimal solution has been obtained !' ) ;
   gotoXY ( 31 , 14 );
   WRITELN ( OUTPUT,'Maximized Z = ',Sum : 8 : 2 ) ;
   gotoXY ( 80 , 24 );
end;
{________________________________________________________________________}


Begin                 (* Main Block *)
   GetZcoef ;
   Concoef ;
   Fillbas ;
   FillCi ;
   FillCj ;
   CalcZj ;
   CalDelj ;
   Unbound := False ;
   PosDelj ;
   While ( Positive = False ) and ( Unbound = False ) do
   begin
      CalTheta ;
      GetLeave ;
      If ( Unbound = False ) then
      begin
         Modibas ;
         FillCi ;
         Nupivrow ;
         Newrow ;
         CalcZj ;
         CalDelj ;
         PosDelj ;
      end;
   end;
   Clrscr ;
   If ( Unbound = True ) then
   begin
      Clrscr ;
      gotoXY ( 24 , 12 ) ;
      WRITELN ( OUTPUT , 'The given problem has Unbounded solution !' );
      gotoXY ( 80 , 24 ) ;
   end
   else
      FinalZ ;
end.
